home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / compat.exe / RUNTEST.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1992-06-26  |  2.2 KB  |  110 lines
  1. Program RUNTEST;
  2.  
  3. {$V-,X+,D+,B-,R- }
  4.  
  5. uses
  6.     Crt, Objects, Drivers, Views, Menus, App, Compat;
  7.  
  8. const
  9.     cmTestA    =  101;  { random-size TP window }
  10.     cmTestB    =  102;  { full-screen TP window }
  11.  
  12. type
  13.     TMyApp    =  OBJECT (TApplication)
  14.       procedure HandleEvent (var Event : TEvent);  VIRTUAL;
  15.       procedure InitMenuBar;  VIRTUAL;
  16.       procedure RunTestA;
  17.       procedure RunTestB;
  18.     end;
  19.  
  20.  
  21.   { ══════════════════════════════════════════════════════════════════════ }
  22.  
  23.  
  24. function  TestBox : word;  far;
  25. { uses ordinary Turbo Pascal I/O }
  26. var  i   : integer;
  27.      S   : string;
  28. begin
  29.   Write ('Enter a STRING: ');
  30.   ReadLn (S);
  31.   For i := 1 to 800 do
  32.     begin
  33.     Write (S + '   ');
  34.     TextColor (i mod 15);
  35.     end;
  36.   TextColor (Black);
  37.   WriteLn;
  38.   Write ('Press <Enter>');
  39.   ReadLn (S);
  40.   TestBox := cmCancel;
  41. end;
  42.  
  43.  
  44.   { ══ TMyApp ════════════════════════════════════════════════════════════ }
  45.  
  46.  
  47. procedure TMyApp.HandleEvent (var Event : TEvent);
  48. begin
  49.   TApplication.HandleEvent (Event);
  50.   If Event.What = evCommand then
  51.     begin
  52.     Case Event.Command of
  53.       cmTestA:    RunTestA;
  54.       cmTestB:    RunTestB;
  55.      else       Exit;
  56.       end;
  57.     ClearEvent (Event);
  58.     end;
  59. end;
  60.  
  61.  
  62. procedure TMyApp.InitMenuBar;
  63. var  R: TRect;
  64. begin
  65.   GetExtent (R);
  66.   R.B.Y := succ (R.A.Y);
  67.   MenuBar := New (PMenuBar, Init (R, NewMenu (
  68.     NewItem ('Test-~A~','',    kbF7,    cmTestA,    hcNoContext,
  69.     NewItem ('~B~',    '',    kbF8,    cmTestB,    hcNoContext,
  70.     nil))
  71.   )));
  72. end;
  73.  
  74.  
  75. procedure TMyApp.RunTestA;
  76. var  R    : TRect;
  77.      D    : PFuncBox;
  78. begin
  79.   R.Assign (0,0,40 + random (40), 6 + random (12));
  80.   R.Move (random (DeskTop^.Size.X - R.B.X),
  81.           random (DeskTop^.Size.Y - R.B.Y));
  82.   D := New (PFuncBox, Init (R, 'Run Test', @TestBox));
  83.   DeskTop^.ExecView (D);
  84.   Dispose (D, Done);
  85. end;
  86.  
  87.  
  88. procedure TMyApp.RunTestB;
  89. var  R    : TRect;
  90.      D    : PFuncBox;
  91. begin
  92.   Application^.GetExtent (R);
  93.   R.Grow (1,1);
  94.   D := New (PFuncBox, Init (R, '', @TestBox));
  95.   Application^.ExecView (New (PFuncBox, Init (R, '', @TestBox)));
  96.   Dispose (D, Done);
  97. end;
  98.  
  99.  
  100.   { ══════════════════════════════════════════════════════════════════════ }
  101.  
  102. var  MyApp: TMyApp;
  103.  
  104.  
  105. Begin
  106.   MyApp.Init;
  107.   MyApp.Run;
  108.   MyApp.Done;
  109. End.
  110.